home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Asyntfn.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  13.4 KB  |  453 lines  |  [TEXT/R*ch]
  1. open List Fnlib Mixture Const Globals Location Types Asynt;
  2.  
  3. fun mkIdInfo (loc, qualid) withOp =
  4.   { qualid = qualid,
  5.     info = { idLoc=loc, withOp=withOp,
  6.              idKind= ref { qualid=qualid, info=VARik }}}
  7. ;
  8.  
  9. fun getConInfo (ii : IdInfo) =
  10.   case #info(! (#idKind (#info ii))) of
  11.       CONik ci => ci
  12.     | _ => fatalError "getConInfo"
  13. ;
  14.  
  15. fun getExConInfo (ii : IdInfo) =
  16.   case #info(!(#idKind (#info ii))) of
  17.       EXCONik ei => ei
  18.     | _ => fatalError "getExConInfo"
  19. ;
  20.  
  21. fun pairExp e1 e2 =
  22.   (xxLR e1 e2, RECexp(ref (RECre(mkPairRow e1 e2))))
  23. ;
  24.  
  25. fun tupleExp (loc, exps) =
  26.   (loc, RECexp(ref (RECre(mkTupleRow exps))))
  27. ;
  28.  
  29. val qQUOTE  = { qual = "General", id = "QUOTE" };
  30. val qANTIQUOTE = { qual = "General", id = "ANTIQUOTE" };
  31.  
  32. fun quoteExp exp =
  33.   let val loc = xLR exp in
  34.     (loc, APPexp((loc,
  35.        VARexp(ref (RESve(mkIdInfo (loc, qQUOTE) false)))), exp))
  36.   end
  37. ;
  38.  
  39. fun antiquoteExp exp =
  40.   let val loc = xLR exp in
  41.     (loc, APPexp((loc,
  42.        VARexp(ref (RESve(mkIdInfo (loc, qANTIQUOTE) false)))), exp))
  43.   end
  44. ;
  45.  
  46. val qNil  = { qual = "", id = "nil" };
  47. val qCons = { qual = "", id = "::" };
  48.  
  49. fun listExp (Loc(l,r), exps) =
  50.   let val locR = Loc(r-1,r) in
  51.     foldR (fn e1 => fn e2 =>
  52.              let val locO = xxLR e1 e2
  53.                  val locI = xxRL e1 e2
  54.              in
  55.                (locO, APPexp((locI,
  56.                         VARexp(ref (RESve(mkIdInfo (locI, qCons) false)))),
  57.                           pairExp e1 e2))
  58.              end)
  59.           (locR, VARexp(ref (RESve(mkIdInfo (locR,qNil) false)))) exps
  60.   end;
  61.  
  62. fun seqExp exps =
  63.   foldR1 (fn e1 => fn e2 =>
  64.             let val loc12 = xxLR e1 e2 in (loc12, SEQexp(e1,e2)) end)
  65.          exps
  66. ;
  67.  
  68. val qX = { qual = "", id = "~x" };
  69.  
  70. fun hashLabelExp (loc, lab) =
  71.   let val pat =
  72.         (loc, RECpat(ref
  73.                 (RECrp([(lab, (loc, VARpat(mkIdInfo (loc,qX) false)))],
  74.                        SOME (fresh3DotType())))))
  75.       and exp =
  76.         (loc, VARexp(ref (RESve(mkIdInfo (loc, qX) false))))
  77.   in (loc, FNexp [MRule([pat],exp)]) end
  78. ;
  79.  
  80. fun mkLabPatOfId (locId as (loc, id)) ty_opt pat_opt =
  81.   let val lab = STRINGlab id
  82.       val var = (loc, VARpat(mkIdInfo (loc, { qual="", id=id }) false))
  83.   in
  84.     case (ty_opt, pat_opt) of
  85.         (SOME ty, SOME pat) =>
  86.           (lab, (xxLR locId pat, LAYEREDpat(var,
  87.                    (xxLR ty pat, TYPEDpat(pat, ty)))))
  88.       | (NONE, SOME pat) =>
  89.           (lab, (xxLR locId pat, LAYEREDpat(var, pat)))
  90.       | (SOME ty, NONE) =>
  91.           (lab, (xxLR locId ty, TYPEDpat(var, ty)))
  92.       | (NONE, NONE) =>
  93.           (lab, var)
  94.   end;
  95.  
  96. fun pairPat p1 p2 =
  97.   let val loc = xxLR p1 p2 in
  98.     (loc, RECpat(ref (RECrp(mkPairRow p1 p2, NONE))))
  99.   end;
  100.  
  101. fun tuplePat (loc, pats) =
  102.   (loc, RECpat(ref (RECrp(mkTupleRow pats, NONE))))
  103. ;
  104.  
  105. fun listPat (Loc(l,r), exps) =
  106.   let val locR = Loc(r-1,r) in
  107.     foldR (fn e1 => fn e2 =>
  108.              let val locO = xxLR e1 e2
  109.                  val locI = xxRL e1 e2
  110.              in
  111.                (locO, CONSpat(mkIdInfo (locI,qCons) true, pairPat e1 e2))
  112.              end)
  113.           (locR, (VARpat (mkIdInfo (locR, qNil) true))) exps
  114.   end;
  115.  
  116. fun tupleTy [t] = t
  117.   | tupleTy ts =
  118.       let val loc = xxLR (hd ts) (last ts) in
  119.         (loc, RECty (mkTupleRow ts))
  120.       end
  121. ;
  122.  
  123. val qIt = { qual = "", id = "it" };
  124.  
  125. fun mkValIt exp =
  126.   let val loc = xLR exp in
  127.     (loc, VALdec
  128.       ([], ([ValBind((loc, VARpat (mkIdInfo (loc, qIt) false)), exp)], [])))
  129.   end;
  130.  
  131. fun domPatAcc (_, pat') ids =
  132.   case pat' of
  133.     SCONpat _ => ids
  134.   | VARpat ii => #id(#qualid ii) :: ids
  135.   | WILDCARDpat => ids
  136.   | NILpat _ => ids
  137.   | CONSpat(_, p) => domPatAcc p ids
  138.   | EXNILpat _ => ids
  139.   | EXCONSpat(_, p) => domPatAcc p ids
  140.   | EXNAMEpat _ => fatalError "domPatAcc"
  141.   | REFpat p => domPatAcc p ids
  142.   | RECpat(ref (RECrp(fs, _))) =>
  143.       foldL_map domPatAcc snd ids fs
  144.   | RECpat(ref (TUPLErp ps)) =>
  145.       foldL domPatAcc ids ps
  146.   | VECpat ps =>
  147.       foldL domPatAcc ids ps
  148.   | INFIXpat _ => fatalError "domPatAcc"
  149.   | PARpat p => domPatAcc p ids
  150.   | TYPEDpat(p,_) => domPatAcc p ids
  151.   | LAYEREDpat(p1,p2) => domPatAcc p2 (domPatAcc p1 ids)
  152. ;
  153.  
  154. fun domPat pat = domPatAcc pat [];
  155.  
  156. fun varsOfPatAcc (_, pat') iis =
  157.   case pat' of
  158.     SCONpat _ => iis
  159.   | VARpat ii => ii :: iis
  160.   | WILDCARDpat => iis
  161.   | NILpat _ => iis
  162.   | CONSpat(_, p) => varsOfPatAcc p iis
  163.   | EXNILpat _ => iis
  164.   | EXCONSpat(_, p) => varsOfPatAcc p iis
  165.   | EXNAMEpat _ => fatalError "varsOfPatAcc"
  166.   | REFpat p => varsOfPatAcc p iis
  167.   | RECpat(ref (RECrp(fs, _))) => foldL_map varsOfPatAcc snd iis fs
  168.   | RECpat(ref (TUPLErp _)) => fatalError "varsOfPatAcc"
  169.   | VECpat ps => foldL varsOfPatAcc iis ps
  170.   | INFIXpat _ => fatalError "varsOfPatAcc"
  171.   | PARpat p => varsOfPatAcc p iis
  172.   | TYPEDpat(p,_) => varsOfPatAcc p iis
  173.   | LAYEREDpat(p1,p2) => varsOfPatAcc p2 (varsOfPatAcc p1 iis)
  174. ;
  175.  
  176. fun varsOfTyAcc (_, ty') iis =
  177.   case ty' of
  178.     TYVARty ii => ii :: iis
  179.   | RECty fs =>
  180.       foldR_map varsOfTyAcc snd iis fs
  181.   | CONty(tys, _) =>
  182.       foldR varsOfTyAcc iis tys
  183.   | FNty(ty, ty') =>
  184.       varsOfTyAcc ty (varsOfTyAcc ty' iis)
  185. ;
  186.  
  187. fun varsOfTy ty = varsOfTyAcc ty [];
  188.  
  189. fun curriedness (MRule(pats,_) :: _) = List.length pats
  190.   | curriedness _ = fatalError "curriedness"
  191. ;
  192.  
  193. fun printIdInfo (ii : IdInfo) =
  194.   let val {qualid, info} = ii in
  195.     if #withOp info then msgString "op " else ();
  196.     printQualId qualid
  197.   end;
  198.  
  199. fun printTyVarSeq [] = ()
  200.   | printTyVarSeq [ii] =
  201.       (printIdInfo ii; msgString " ")
  202.   | printTyVarSeq iis =
  203.       (msgString "("; printSeq printIdInfo ", " iis;
  204.        msgString ") ")
  205. ;
  206.  
  207. fun printTy (_, ty') =
  208.   case ty' of
  209.     TYVARty ii =>
  210.       msgString (#id (#qualid ii))
  211.   | RECty fs =>
  212.       (msgString "{"; printSeq printRecTyField ", " fs; msgString ")")
  213.   | CONty(ts, tc) =>
  214.       (printTySeq ts; printQualId (#qualid tc))
  215.   | FNty(t, t') =>
  216.       (msgString "("; printTy t; msgString " -> "; printTy t';
  217.        msgString ")")
  218.  
  219. and printRecTyField (lab, ty) =
  220.   (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2); printTy ty;
  221.    msgEBlock())
  222.  
  223. and printTySeq [] = ()
  224.   | printTySeq [t] =
  225.       (printTy t; msgString " ")
  226.   | printTySeq ts =
  227.       (msgString "("; printSeq printTy ", " ts;
  228.        msgString ")")
  229. ;
  230.  
  231. fun printOvlType ovltype tau =
  232. (
  233.   msgString
  234.     (case ovltype of
  235.          REGULARo => "</ "
  236.        | OVL1NNo => "<num -> num/ "
  237.        | OVL1NSo => "<numtext -> string/ "
  238.        | OVL2NNBo => "<num * num -> bool/ "
  239.        | OVL2NNNo => "<num * num -> num/ "
  240.        | OVL1TXXo => "<'a -> 'a/ "
  241.        | OVL1TPUo => "<(ppstream -> 'a -> unit) -> unit/ "
  242.        | OVL2EEBo => "<''a * ''a -> bool/ ");
  243.   printType tau;
  244.   msgString " > "
  245. );
  246.  
  247. fun printExp (_, exp') =
  248.   case exp' of
  249.     SCONexp (scon, _) =>
  250.       printSCon scon
  251.   | VARexp(ref(RESve ii)) =>
  252.       printIdInfo ii
  253.   | VARexp(ref(OVLve(ii, ovltype, tau))) =>
  254.       (printIdInfo ii;
  255.        printOvlType ovltype tau)
  256.   | RECexp(ref (RECre fs)) =>
  257.       (msgString "{"; printSeq printExpField ", " fs;
  258.        msgString "}")
  259.   | RECexp(ref (TUPLEre es)) =>
  260.       (msgString "("; printSeq printExp ", " es;
  261.        msgString ")")
  262.   | VECexp es =>
  263.       (msgString "#["; printSeq printExp ", " es;
  264.        msgString "]")
  265.   | PARexp e => printExp e
  266.   | FNexp mrules =>
  267.       (msgString "(fn "; printSeq printMRule " | " mrules;
  268.        msgString ")")
  269.   | APPexp (e1,e2) =>
  270.       (msgString "("; printSeq printExp " " [e1,e2];
  271.        msgString ")")
  272.   | LETexp (dec,exp) =>
  273.       (msgString "let "; printDec dec; msgString " in ";
  274.        printExp exp; msgString " end")
  275.   | INFIXexp es =>
  276.       (msgString "(INFIXexp ";
  277.        printSeq printExp " " es;
  278.        msgString ")")
  279.   | TYPEDexp(exp,ty) =>
  280.       (msgString "("; printExp exp; msgString " : ";
  281.        printTy ty; msgString ")")
  282.   | ANDALSOexp(exp1,exp2) =>
  283.       (printExp exp1; msgString " andalso "; printExp exp2)
  284.   | ORELSEexp(exp1,exp2) =>
  285.       (printExp exp1; msgString " orelse "; printExp exp2)
  286.   | HANDLEexp(exp, mrules) =>
  287.       (msgString "("; printExp exp; msgString " handle ";
  288.        printSeq printMRule " | " mrules; msgString ")")
  289.   | RAISEexp exp =>
  290.       (msgString "raise "; printExp exp)
  291.   | IFexp(exp0,exp1,exp2) =>
  292.       (msgString "if "; printExp exp0; msgString " then ";
  293.        printExp exp1; msgString " else "; printExp exp2)
  294.   | WHILEexp(exp1,exp2) =>
  295.       (msgString "while "; printExp exp1; msgString " do ";
  296.        printExp exp2)
  297.   | SEQexp(exp1,exp2) =>
  298.       (msgString "("; printExp exp1; msgString "; ";
  299.        printExp exp2; msgString ")")
  300.  
  301. and printExpField (lab, e) =
  302.   (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2);
  303.    printExp e; msgEBlock())
  304.  
  305. and printMRule (MRule(ps, e)) =
  306.       (printSeq printPat " => " ps; msgString " => "; printExp e)
  307.  
  308. and printPat (_, pat') =
  309.   case pat' of
  310.     SCONpat (scon , _) => printSCon scon
  311.   | VARpat ii => printIdInfo ii
  312.   | WILDCARDpat => msgString "_"
  313.   | NILpat ii => printIdInfo ii
  314.   | CONSpat(ii, p) =>
  315.       (msgString "("; printIdInfo ii; printPat p; msgString ")")
  316.   | EXNILpat ii => printIdInfo ii
  317.   | EXCONSpat(ii,p) =>
  318.       (msgString "("; printIdInfo ii; printPat p; msgString ")")
  319.   | EXNAMEpat ii =>
  320.       (msgString "<"; printIdInfo ii; msgString ">")
  321.   | REFpat p =>
  322.       (msgString "("; msgString "ref "; printPat p; msgString ")")
  323.   | RECpat(ref (RECrp(fs, dots))) =>
  324.       (msgString "{"; printSeq printPatField ", " fs;
  325.        case dots of
  326.            NONE =>
  327.              msgString "}"
  328.          | SOME _ =>
  329.              msgString ", ...}")
  330.   | RECpat(ref (TUPLErp ps)) =>
  331.       (msgString "("; printSeq printPat ", " ps; msgString ")")
  332.   | VECpat ps =>
  333.       (msgString "#["; printSeq printPat ", " ps; msgString "]")
  334.   | PARpat p =>
  335.       printPat p
  336.   | INFIXpat ps =>
  337.       (msgString "(INFIXpat";
  338.        app (fn p => (msgString " "; printPat p)) ps;
  339.        msgString ")")
  340.   | TYPEDpat(pat, ty) =>
  341.       (msgString "("; printPat pat; msgString " : ";
  342.        printTy ty; msgString ")")
  343.   | LAYEREDpat(pat1, pat2) =>
  344.       (msgString "("; printPat pat1; msgString " as ";
  345.        printPat pat2; msgString ")")
  346.  
  347. and printPatField (lab, pat) =
  348.   (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2);
  349.    printPat pat; msgEBlock())
  350.  
  351. and printDec (_, dec') =
  352.   case dec' of
  353.     VALdec (tvs, (pvbs, rvbs)) =>
  354.       (msgString "val "; printTyVarSeq tvs; 
  355.        case (pvbs, rvbs) of
  356.           (_, []) => printValBindSeq pvbs
  357.         | ([], _) => (msgString "rec "; printValBindSeq rvbs)
  358.         | (_, _) => (printValBindSeq pvbs; msgString " and rec ";
  359.                      printValBindSeq rvbs))
  360.   | PRIM_VALdec vbs =>
  361.       (msgString "prim_val "; printSeq printPrimValBind " and " vbs)
  362.   | FUNdec (tvs, fvalbind) =>
  363.       (msgString "fun "; printTyVarSeq tvs; 
  364.        printSeq printFValBind " and " fvalbind)
  365.   | TYPEdec tbs =>
  366.       (msgString "type "; printSeq printTypBind " and " tbs)
  367.   | PRIM_TYPEdec(eq, tbs) =>
  368.       (msgString "prim_";
  369.        msgString
  370.          (case eq of
  371.               FALSEequ => ""
  372.             | TRUEequ  => "eq"
  373.             | REFequ   => "EQ");
  374.        msgString "type "; printSeq printPrimTypBind " and " tbs)
  375.   | DATATYPEdec(dbs, tbs_opt) =>
  376.       (msgString "datatype "; printSeq printDatBind " and " dbs;
  377.        printWithtype tbs_opt)
  378.   | ABSTYPEdec(dbs, tbs_opt, dec) =>
  379.       (msgString "abstype "; printSeq printDatBind " and " dbs;
  380.        printWithtype tbs_opt;
  381.        msgString " with "; printDec dec)
  382.   | EXCEPTIONdec ebs =>
  383.       (msgString "exception "; printSeq printExBind " and " ebs)
  384.   | LOCALdec(dec1,dec2) =>
  385.       (msgString "local "; printDec dec1; msgString " in ";
  386.        printDec dec2)
  387.   | OPENdec ids =>
  388.       (msgString "OPEN "; printSeq msgString " " ids)
  389.   | EMPTYdec => ()
  390.   | SEQdec(dec1,dec2) =>
  391.       (printDec dec1; msgString "; "; printDec dec2)
  392.   | FIXITYdec(status, ids) =>
  393.       (case status of
  394.            INFIXst i =>
  395.              (msgString "INFIX "; msgInt i; msgString " ")
  396.          | INFIXRst i =>
  397.              (msgString "INFIXR "; msgInt i; msgString " ")
  398.          | NONFIXst =>
  399.              msgString "NONFIX ";
  400.        printSeq msgString " " ids)
  401.  
  402. and printValBindSeq vbs =
  403.   printSeq printValBind " and " vbs
  404.  
  405. and printValBind (ValBind(p, e)) =
  406.   (msgIBlock 0; printPat p; msgString " ="; msgBreak(1, 2);
  407.    printExp e; msgEBlock())
  408.  
  409. and printPrimValBind(ii, ty, arity, name) =
  410.   (msgIBlock 0; printIdInfo ii;
  411.    msgString " :"; msgBreak(1, 2);
  412.    printTy ty; msgString " ="; msgBreak(1, 2);
  413.    msgInt arity; msgString " "; printSCon (STRINGscon name);
  414.    msgEBlock())
  415.  
  416. and printFValBind (_, fclauses) =
  417.   (printSeq printFClause " | " fclauses)
  418.  
  419. and printFClause (FClause (pats, exp)) =
  420.   (msgIBlock 0; printSeq printPat " " pats; msgString " ="; msgBreak(1, 2);
  421.    printExp exp; msgEBlock())
  422.  
  423. and printWithtype (SOME tbs) =
  424.       (msgString " withtype "; printSeq printTypBind " and " tbs)
  425.   | printWithtype NONE = ()
  426.  
  427. and printTypBind (tvs, tc, t) =
  428.   (msgIBlock 0; printTyVarSeq tvs; msgString (#id (#qualid tc));
  429.    msgString " ="; msgBreak(1, 2);
  430.    printTy t; msgEBlock())
  431.  
  432. and printPrimTypBind (tvs, tc) =
  433.   (printTyVarSeq tvs; msgString (#id (#qualid tc)))
  434.  
  435. and printDatBind (tvs, tc, cbs) =
  436.   (msgIBlock 0; printTyVarSeq tvs; msgString (#id (#qualid tc));
  437.    msgString " ="; msgBreak(1, 2);
  438.    printSeq printConBind " | " cbs; msgEBlock())
  439.  
  440. and printConBind (ConBind(ii, SOME t)) =
  441.       (printIdInfo ii; msgString " of "; printTy t)
  442.   | printConBind (ConBind(ii, NONE)) =
  443.       printIdInfo ii
  444.  
  445. and printExBind (EXDECexbind(ii, SOME t)) =
  446.       (printIdInfo ii; msgString " of "; printTy t)
  447.   | printExBind (EXDECexbind(ii, NONE)) =
  448.       printIdInfo ii
  449.   | printExBind (EXEQUALexbind(ii, ii')) =
  450.       (msgIBlock 0; printIdInfo ii; msgString " ="; msgBreak(1, 2);
  451.        printIdInfo ii'; msgEBlock())
  452. ;
  453.